home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / MacPerl 5.1.3 / Mac_Perl_513_src / perl5.002 / utils / h2ph.PL < prev    next >
Encoding:
Perl Script  |  1996-04-06  |  6.9 KB  |  310 lines  |  [TEXT/MPS ]
  1. #!/usr/local/bin/perl
  2.  
  3. use Config;
  4. use File::Basename qw(&basename &dirname);
  5.  
  6. # List explicitly here the variables you want Configure to
  7. # generate.  Metaconfig only looks for shell variables, so you
  8. # have to mention them as if they were shell variables, not
  9. # %Config entries.  Thus you write
  10. #  $startperl
  11. # to ensure Configure will look for $Config{startperl}.
  12. # Wanted:  $archlibexp
  13.  
  14. # This forces PL files to create target in same directory as PL file.
  15. # This is so that make depend always knows where to find PL derivatives.
  16. chdir(dirname($0));
  17. ($file = basename($0)) =~ s/\.PL$//;
  18. $file =~ s/\.pl$//
  19.     if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"
  20.  
  21. open OUT,">$file" or die "Can't create $file: $!";
  22.  
  23. print "Extracting $file (with variable substitutions)\n";
  24.  
  25. # In this section, perl variables will be expanded during extraction.
  26. # You can use $Config{...} to use Configure variables.
  27.  
  28. print OUT <<"!GROK!THIS!";
  29. $Config{'startperl'}
  30.     eval 'exec perl -S \$0 "\$@"'
  31.     if 0;
  32.  
  33. 'di ';
  34. 'ds 00 \"';
  35. 'ig 00 ';
  36.  
  37. \$perlincl = "$Config{archlibexp}";
  38.  
  39. !GROK!THIS!
  40.  
  41. # In the following, perl variables are not expanded during extraction.
  42.  
  43. print OUT <<'!NO!SUBS!';
  44.  
  45. chdir '/usr/include' || die "Can't cd /usr/include";
  46.  
  47. @isatype = split(' ',<<END);
  48.     char    uchar    u_char
  49.     short    ushort    u_short
  50.     int    uint    u_int
  51.     long    ulong    u_long
  52.     FILE
  53. END
  54.  
  55. @isatype{@isatype} = (1) x @isatype;
  56. $inif = 0;
  57.  
  58. @ARGV = ('-') unless @ARGV;
  59.  
  60. foreach $file (@ARGV) {
  61.     if ($file eq '-') {
  62.     open(IN, "-");
  63.     open(OUT, ">-");
  64.     }
  65.     else {
  66.     ($outfile = $file) =~ s/\.h$/.ph/ || next;
  67.     print "$file -> $outfile\n";
  68.     if ($file =~ m|^(.*)/|) {
  69.         $dir = $1;
  70.         if (!-d "$perlincl/$dir") {
  71.         mkdir("$perlincl/$dir",0777);
  72.         }
  73.     }
  74.     open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
  75.     open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n";
  76.     }
  77.     while (<IN>) {
  78.     chop;
  79.     while (/\\$/) {
  80.         chop;
  81.         $_ .= <IN>;
  82.         chop;
  83.     }
  84.     if (s:/\*:\200:g) {
  85.         s:\*/:\201:g;
  86.         s/\200[^\201]*\201//g;    # delete single line comments
  87.         if (s/\200.*//) {        # begin multi-line comment?
  88.         $_ .= '/*';
  89.         $_ .= <IN>;
  90.         redo;
  91.         }
  92.     }
  93.     if (s/^#\s*//) {
  94.         if (s/^define\s+(\w+)//) {
  95.         $name = $1;
  96.         $new = '';
  97.         s/\s+$//;
  98.         if (s/^\(([\w,\s]*)\)//) {
  99.             $args = $1;
  100.             if ($args ne '') {
  101.             foreach $arg (split(/,\s*/,$args)) {
  102.                 $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
  103.                 $curargs{$arg} = 1;
  104.             }
  105.             $args =~ s/\b(\w)/\$$1/g;
  106.             $args = "local($args) = \@_;\n$t    ";
  107.             }
  108.             s/^\s+//;
  109.             do expr();
  110.             $new =~ s/(["\\])/\\$1/g;
  111.             if ($t ne '') {
  112.             $new =~ s/(['\\])/\\$1/g;
  113.             print OUT $t,
  114.               "eval 'sub $name {\n$t    ${args}eval \"$new\";\n$t}';\n";
  115.             }
  116.             else {
  117.             print OUT "sub $name {\n    ${args}eval \"$new\";\n}\n";
  118.             }
  119.             %curargs = ();
  120.         }
  121.         else {
  122.             s/^\s+//;
  123.             do expr();
  124.             $new = 1 if $new eq '';
  125.             if ($t ne '') {
  126.             $new =~ s/(['\\])/\\$1/g;
  127.             print OUT $t,"eval 'sub $name {",$new,";}';\n";
  128.             }
  129.             else {
  130.             print OUT $t,"sub $name {",$new,";}\n";
  131.             }
  132.         }
  133.         }
  134.         elsif (/^include\s*<(.*)>/) {
  135.         ($incl = $1) =~ s/\.h$/.ph/;
  136.         print OUT $t,"require '$incl';\n";
  137.         }
  138.         elsif (/^ifdef\s+(\w+)/) {
  139.         print OUT $t,"if (defined &$1) {\n";
  140.         $tab += 4;
  141.         $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  142.         }
  143.         elsif (/^ifndef\s+(\w+)/) {
  144.         print OUT $t,"if (!defined &$1) {\n";
  145.         $tab += 4;
  146.         $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  147.         }
  148.         elsif (s/^if\s+//) {
  149.         $new = '';
  150.         $inif = 1;
  151.         do expr();
  152.         $inif = 0;
  153.         print OUT $t,"if ($new) {\n";
  154.         $tab += 4;
  155.         $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  156.         }
  157.         elsif (s/^elif\s+//) {
  158.         $new = '';
  159.         $inif = 1;
  160.         do expr();
  161.         $inif = 0;
  162.         $tab -= 4;
  163.         $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  164.         print OUT $t,"}\n${t}elsif ($new) {\n";
  165.         $tab += 4;
  166.         $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  167.         }
  168.         elsif (/^else/) {
  169.         $tab -= 4;
  170.         $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  171.         print OUT $t,"}\n${t}else {\n";
  172.         $tab += 4;
  173.         $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  174.         }
  175.         elsif (/^endif/) {
  176.         $tab -= 4;
  177.         $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  178.         print OUT $t,"}\n";
  179.         }
  180.     }
  181.     }
  182.     print OUT "1;\n";
  183. }
  184.  
  185. sub expr {
  186.     while ($_ ne '') {
  187.     s/^(\s+)//        && do {$new .= ' '; next;};
  188.     s/^(0x[0-9a-fA-F]+)//    && do {$new .= $1; next;};
  189.     s/^(\d+)[LlUu]*//    && do {$new .= $1; next;};
  190.     s/^("(\\"|[^"])*")//    && do {$new .= $1; next;};
  191.     s/^'((\\"|[^"])*)'//    && do {
  192.         if ($curargs{$1}) {
  193.         $new .= "ord('\$$1')";
  194.         }
  195.         else {
  196.         $new .= "ord('$1')";
  197.         }
  198.         next;
  199.     };
  200.     s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
  201.         $new .= '$sizeof';
  202.         next;
  203.     };
  204.     s/^([_a-zA-Z]\w*)//    && do {
  205.         $id = $1;
  206.         if ($id eq 'struct') {
  207.         s/^\s+(\w+)//;
  208.         $id .= ' ' . $1;
  209.         $isatype{$id} = 1;
  210.         }
  211.         elsif ($id eq 'unsigned') {
  212.         s/^\s+(\w+)//;
  213.         $id .= ' ' . $1;
  214.         $isatype{$id} = 1;
  215.         }
  216.         if ($curargs{$id}) {
  217.         $new .= '$' . $id;
  218.         }
  219.         elsif ($id eq 'defined') {
  220.         $new .= 'defined';
  221.         }
  222.         elsif (/^\(/) {
  223.         s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i;    # cheat
  224.         $new .= " &$id";
  225.         }
  226.         elsif ($isatype{$id}) {
  227.         if ($new =~ /{\s*$/) {
  228.             $new .= "'$id'";
  229.         }
  230.         elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
  231.             $new =~ s/\(\s*$//;
  232.             s/^[\s*]*\)//;
  233.         }
  234.         else {
  235.             $new .= q(').$id.q(');
  236.         }
  237.         }
  238.         else {
  239.         if ($inif && $new !~ /defined\s*\($/) {
  240.             $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
  241.         } 
  242.         elsif (/^\[/) { 
  243.             $new .= ' $' . $id;
  244.         }
  245.         else {
  246.             $new .= ' &' . $id;
  247.         }
  248.         }
  249.         next;
  250.     };
  251.     s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
  252.     }
  253. }
  254. ##############################################################################
  255.  
  256.     # These next few lines are legal in both Perl and nroff.
  257.  
  258. .00 ;            # finish .ig
  259.  
  260. 'di            \" finish diversion--previous line must be blank
  261. .nr nl 0-1        \" fake up transition to first page again
  262. .nr % 0            \" start at page 1
  263. '; __END__ ############# From here on it's a standard manual page ############
  264. .TH H2PH 1 "August 8, 1990"
  265. .AT 3
  266. .SH NAME
  267. h2ph \- convert .h C header files to .ph Perl header files
  268. .SH SYNOPSIS
  269. .B h2ph [headerfiles]
  270. .SH DESCRIPTION
  271. .I h2ph
  272. converts any C header files specified to the corresponding Perl header file
  273. format.
  274. It is most easily run while in /usr/include:
  275. .nf
  276.  
  277.     cd /usr/include; h2ph * sys/*
  278.  
  279. .fi
  280. If run with no arguments, filters standard input to standard output.
  281. .SH ENVIRONMENT
  282. No environment variables are used.
  283. .SH FILES
  284. /usr/include/*.h
  285. .br
  286. /usr/include/sys/*.h
  287. .br
  288. etc.
  289. .SH AUTHOR
  290. Larry Wall
  291. .SH "SEE ALSO"
  292. perl(1)
  293. .SH DIAGNOSTICS
  294. The usual warnings if it can't read or write the files involved.
  295. .SH BUGS
  296. Doesn't construct the %sizeof array for you.
  297. .PP
  298. It doesn't handle all C constructs, but it does attempt to isolate
  299. definitions inside evals so that you can get at the definitions
  300. that it can translate.
  301. .PP
  302. It's only intended as a rough tool.
  303. You may need to dicker with the files produced.
  304. .ex
  305. !NO!SUBS!
  306.  
  307. close OUT or die "Can't close $file: $!";
  308. chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
  309. exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
  310.